{-# LANGUAGE TypeOperators, ExistentialQuantification, TypeFamilies #-}
----------------------------------------------------------------------
-- |
-- Module      :  Data.BFunction
-- Copyright   :  (c) Sergey Sichevskiy 2012
-- License     :  BSD3
-- 
-- Maintainer  :  s.sichevskij@gmal.com
-- Stability   :  experimental
--  
-- Основные определения для функции заданной в конечной области определения
--
----------------------------------------------------------------------

module Data.BFunction
 ( (:~>:)(..)
 ) where

import Control.Applicative 
import Data.AdditiveGroup (AdditiveGroup(..))
import Data.VectorSpace   (VectorSpace(..))

import Data.NumInstances ()

data a :~>: b = (Ord a) => F (a,a) (a->b) | C b

noOv :: String -> String -> a
noOv ty meth = error $ meth ++ ": No overloading for " ++ ty

noFun :: String -> a
noFun = noOv "function"

---- Наследование типа данных (:~>:) от нужных классов

instance (Show a, Show b) => Show (a :~>: b) where
   show (F b  _) = show b
   show (C v)    = show v

instance (Eq a, Eq b) => Eq (a :~>: b) where
   (==) =  noFun "(==)"
   (/=) =  noFun "(/=)"

instance Functor ( (:~>:) a ) where
   fmap f x = pure f <*> x

instance Applicative ( (:~>:) a ) where
   pure a = C a

   (<*>) (C f)       (C a)         = C   $ f a
   (<*>) (C f)       (F b a)       = F b $ f . a
   (<*>) (F b f)     (C a)         = F b $ flip f a
   (<*>) (F (l,r) f) (F (l',r') a) = F b'$ \x -> f x $ a x
     where
       b' = ( min l l', max r r' )

-- Standard instance for an applicative functor applied to a vector space.
instance AdditiveGroup v => AdditiveGroup (a :~>: v) where
  zeroV   = pure   zeroV
  (^+^)   = liftA2 (^+^)
  negateV = fmap   negateV

instance VectorSpace v => VectorSpace (a :~>: v) where
  type Scalar (a :~>: v) = Scalar v
--  (*^) = liftA2 (*^)
  (*^) s = fmap (s *^)

instance (Num b) => Num (a :~>: b) where
   negate      = fmap negate
   fromInteger = pure . fromInteger
   abs         = fmap abs
   signum      = fmap signum

   (*) (F (l,r) f) (F (l',r') f')
     | r < l' || r' < l = C 0
     | otherwise        = F b' $ f * f'
     where b' = (max l l', min r r')

   (*) a b     = liftA2 (*) a b
   (+) a b     = liftA2 (+) a b

instance (Fractional b) => Fractional (a :~>: b) where
   recip        = fmap recip
   fromRational = pure . fromRational

instance Floating b => Floating (a :~>: b) where
  pi    = pure pi
  sqrt  = fmap sqrt
  exp   = fmap exp
  log   = fmap log
  sin   = fmap sin
  cos   = fmap cos
  asin  = fmap asin
  atan  = fmap atan
  acos  = fmap acos
  sinh  = fmap sinh
  cosh  = fmap cosh
  asinh = fmap asinh
  atanh = fmap atanh
  acosh = fmap acosh